home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / bcomp / comp.scm next >
Text File  |  1995-10-13  |  18KB  |  574 lines
  1. ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  3.  
  4.  
  5. ; This is file comp.scm.
  6.  
  7. ;;;; The byte-code compiler
  8.  
  9. ; This is a two-phase compiler.  The first phase does macro expansion,
  10. ; variable resolution, and instruction selection, and computes the
  11. ; size of the code vector.  The second phase (assembly) creates the
  12. ; code vector, "template" (literals vector), and debugging data
  13. ; structures.
  14.  
  15. ; The output of the first phase (the COMPILE- and INSTRUCTION-
  16. ; routines) and the input to the second phase (SEGMENT->TEMPLATE) is a
  17. ; "segment."  A segment is a pair (size . proc) where size is the size
  18. ; of the code segment in bytes, and proc is a procedure that during
  19. ; phase 2 will store the segment's bytes into the code vector.
  20.  
  21. ; A "cenv" maps lexical variables to <level, offset> pairs.  Level is
  22. ; the variable's distance from the root of the environment; 0 means
  23. ; outermost level, and higher numbers mean deeper lexical levels.  The
  24. ; offset is the position of the variable within its level's
  25. ; environment vector.
  26.  
  27. ; Optimizations are marked with +++, and may be flushed if desired.
  28.  
  29.  
  30. (define (compile-top exp cenv depth cont)
  31.   (compile exp (initial-cenv cenv) depth cont))
  32.  
  33.  
  34. ; Main dispatch for compiling a single expression.
  35.  
  36. (define (compile exp cenv depth cont)
  37.   (let ((node (type-check (classify exp cenv) cenv)))
  38.     ((operator-table-ref compilators (node-operator-id node))
  39.      node
  40.      cenv
  41.      depth
  42.      cont)))
  43.  
  44. ; Specialists
  45.  
  46. (define compilators
  47.   (make-operator-table (lambda (node cenv depth cont)
  48.              (generate-trap cont
  49.                     "not valid in expression context"
  50.                     (schemify node cenv)))
  51.                (lambda (frob)  ;for let-syntax, with-aliases, etc.
  52.              (lambda (node cenv depth cont)
  53.                (call-with-values (lambda () (frob node cenv))
  54.                  (lambda (form cenv)
  55.                    (compile form cenv depth cont)))))))
  56.  
  57. (define (define-compilator name type proc)
  58.   (operator-define! compilators name type proc))
  59.  
  60. (define-compilator 'literal #f
  61.   (lambda (node cenv depth cont)
  62.     (let ((obj (node-form node)))
  63.       (if (eq? obj #f)
  64.       ;; +++ hack for bootstrap from Schemes that don't distinguish #f/()
  65.       (deliver-value (instruction (enum op false)) cont)
  66.       (compile-constant obj depth cont)))))
  67.  
  68. (define-compilator 'quote syntax-type
  69.   (lambda (node cenv depth cont)
  70.     (let ((exp (node-form node)))
  71.       cenv                ;ignored
  72.       (let ((obj (cadr exp)))
  73.     (compile-constant obj depth cont)))))
  74.  
  75. (define (compile-constant obj depth cont)
  76.   (if (ignore-values-cont? cont)
  77.       empty-segment            ;+++ dead code
  78.       (deliver-value (instruction-with-literal (enum op literal) obj)
  79.              cont)))
  80.  
  81. ; Variable reference
  82.  
  83. (define-compilator 'name #f
  84.   (lambda (node cenv depth cont)
  85.     (let* ((binding (name-node-binding node cenv))
  86.        (name (node-form node)))
  87.       (deliver-value (if (and (binding? binding)
  88.                   (pair? (binding-place binding)))
  89.              (let* ((level+over (binding-place binding))
  90.                 (back (- (environment-level cenv)
  91.                      (car level+over)))
  92.                 (over (cdr level+over)))
  93.                (case back
  94.                  ((0) (instruction (enum op local0) over)) ;+++
  95.                  ((1) (instruction (enum op local1) over)) ;+++
  96.                  ((2) (instruction (enum op local2) over)) ;+++
  97.                  (else (instruction (enum op local) back over))))
  98.              (instruction-with-location
  99.                     (enum op global)
  100.                 (get-location binding cenv name value-type)))
  101.              cont))))
  102.  
  103. ; Assignment
  104.  
  105. (define-compilator 'set! syntax-type
  106.   (lambda (node cenv depth cont)
  107.     (let* ((exp (node-form node))
  108.        (lhs-node (classify (cadr exp) cenv))
  109.        (name (node-form lhs-node))
  110.        ;; Error if not a name node...
  111.        (binding (name-node-binding lhs-node cenv)))
  112.       (sequentially
  113.        (compile (caddr exp) cenv depth (named-cont name))
  114.        (deliver-value
  115.     (if (and (binding? binding) (pair? (binding-place binding)))
  116.         (let ((level+over (binding-place binding)))
  117.           (instruction (enum op set-local!)
  118.                (- (environment-level cenv) (car level+over))
  119.                (cdr level+over)))
  120.         (instruction-with-location (enum op set-global!)
  121.           (get-location binding cenv name usual-variable-type)))
  122.     cont)))))
  123.  
  124. ; Conditional
  125.  
  126. (define-compilator 'if syntax-type
  127.   (lambda (node cenv depth cont)
  128.     (let ((exp (node-form node))
  129.       (alt-label (make-label))
  130.       (join-label (make-label)))
  131.       (sequentially
  132.        ;; Test
  133.        (compile (cadr exp) cenv depth (fall-through-cont node 1))
  134.        (instruction-using-label (enum op jump-if-false) alt-label)
  135.        ;; Consequent
  136.        (compile (caddr exp) cenv depth cont)
  137.        (if (fall-through-cont? cont)
  138.        (instruction-using-label (enum op jump) join-label)
  139.        empty-segment)
  140.        ;; Alternate
  141.        (attach-label alt-label
  142.              (compile (cadddr exp) cenv depth cont))
  143.        (attach-label join-label
  144.              empty-segment)))))
  145.  
  146.  
  147. (define-compilator 'begin syntax-type
  148.   (lambda (node cenv depth cont)
  149.     (let ((exp (node-form node)))
  150.       (compile-begin (cdr exp) cenv depth cont))))
  151.  
  152. (define compile-begin
  153.   (let ((operator/begin (get-operator 'begin)))
  154.     (lambda (exp-list cenv depth cont)
  155.       (if (null? exp-list)
  156.       (generate-trap cont "null begin")
  157.       (let ((dummy
  158.          (make-node operator/begin ;For debugging database
  159.                 `(begin ,@exp-list))))
  160.         (let loop ((exp-list exp-list) (i 1))
  161.           (if (null? (cdr exp-list))
  162.           (compile (car exp-list) cenv depth cont)
  163.           (careful-sequentially
  164.            (compile (car exp-list) cenv depth
  165.                 (ignore-values-cont dummy i))
  166.            (loop (cdr exp-list) (+ i 1))
  167.            depth
  168.            cont))))))))
  169.  
  170.  
  171. ; Compile a call
  172.  
  173. (define (compile-call node cenv depth cont)
  174.   (if (node-ref node 'type-error)
  175.       (compile-unknown-call node cenv depth cont)
  176.       (let ((proc-node (classify (car (node-form node)) cenv)))
  177.     (if (and (lambda-node? proc-node)
  178.          (not (n-ary? (cadr (node-form proc-node)))))
  179.         (compile-redex proc-node (cdr (node-form node)) cenv depth cont)
  180.         (let ((new-node (maybe-transform-call proc-node node cenv)))
  181.           (if (eq? new-node node)
  182.           (compile-unknown-call node cenv depth cont)
  183.           (compile new-node cenv depth cont)))))))
  184.  
  185. (define-compilator 'call #f compile-call)
  186.  
  187.  
  188. ; A redex is a call of the form ((lambda (x1 ... xn) body ...) e1 ... en).
  189.  
  190. (define lambda-node? (node-predicate 'lambda))
  191.  
  192. (define (compile-redex proc-node args cenv depth cont)
  193.   (let* ((proc-exp (node-form proc-node))
  194.      (formals (cadr proc-exp))
  195.      (body (cddr proc-exp)))
  196.     (if (null? formals)
  197.     (compile-body body cenv depth cont) ;+++
  198.     (maybe-push-continuation
  199.      (sequentially 
  200.       (push-all-with-names args formals cenv 0)
  201.       (compile-lambda-code formals body cenv (cont-name cont)))
  202.      depth
  203.      cont))))
  204.  
  205. ; Compile a call to a computed procedure.
  206.  
  207. (define (compile-unknown-call node cenv depth cont)
  208.   (let ((exp (node-form node)))
  209.     (let ((call (sequentially (push-arguments node cenv 0)
  210.                   (compile (car exp)
  211.                        cenv
  212.                        (length (cdr exp))
  213.                        (fall-through-cont node 0))
  214.                   (instruction (enum op call) (length (cdr exp))))))
  215.       (maybe-push-continuation call depth cont))))
  216.  
  217. (define (maybe-push-continuation code depth cont)
  218.   (if (return-cont? cont) 
  219.       code
  220.       (let ((label (make-label)))
  221.     (sequentially (instruction-using-label (enum op make-cont)
  222.                            label
  223.                            depth)
  224.               (note-source-code (cont-source-info cont)
  225.                     code)
  226.               (attach-label label
  227.                     (cont-segment cont))))))
  228.  
  229. ; Continuation is implicitly fall-through.
  230.  
  231. (define (push-arguments node cenv depth)
  232.   (let recur ((args (cdr (node-form node))) (depth depth) (i 1))
  233.     (if (null? args)
  234.     empty-segment
  235.     (sequentially (compile (car args) cenv depth
  236.                    (fall-through-cont node i))
  237.               (instruction (enum op push))
  238.               (recur (cdr args) (+ depth 1) (+ i 1))))))
  239.  
  240. (define (push-all-with-names exp-list names cenv depth)
  241.   (if (null? exp-list)
  242.       empty-segment
  243.       (sequentially (compile (car exp-list)
  244.                  cenv depth
  245.                  (named-cont (car names)))
  246.             (instruction (enum op push))
  247.                     (push-all-with-names (cdr exp-list)
  248.                      (cdr names)
  249.                      cenv
  250.                      (+ depth 1)))))
  251.      
  252. ; OK, now that you've got all that under your belt, here's LAMBDA.
  253.  
  254. (define-compilator 'lambda syntax-type
  255.   (lambda (node cenv depth cont)
  256.     (let ((exp (node-form node))
  257.       (name (cont-name cont)))
  258.       (deliver-value
  259.        (instruction-with-template (enum op closure)
  260.                   (compile-lambda exp
  261.                           cenv
  262.                           ;; Hack for constructors.
  263.                           ;; Cf. disclose method
  264.                           ;; (if name #t #f)
  265.                           #f)
  266.                   name)
  267.        cont))))
  268.  
  269. (define (compile-lambda exp cenv body-name)
  270.   (let* ((formals (cadr exp))
  271.      (nargs (number-of-required-args formals)))
  272.     (sequentially
  273.      ;; Check number of arguments
  274.      (if (n-ary? formals)
  275.      (if (pair? formals)
  276.          (instruction (enum op check-nargs>=) nargs)
  277.          empty-segment)        ;+++ (lambda x ...) needs no check
  278.      (instruction (enum op check-nargs=) nargs))
  279.      (compile-lambda-code formals (cddr exp) cenv body-name))))
  280.  
  281. ; name isn't the name of the procedure, it's the name to be given to
  282. ; the value that the procedure will return.
  283.  
  284. (define (compile-lambda-code formals body cenv name)
  285.   (if (null? formals)
  286.       (compile-body body        ;+++ Don't make null environment
  287.             cenv
  288.             0
  289.             (return-cont name))
  290.       ;; (if (node-ref node 'no-inferior-lambdas) ...)
  291.       (sequentially
  292.        (let ((nargs (number-of-required-args formals)))
  293.      (if (n-ary? formals)
  294.          (sequentially
  295.           (instruction (enum op make-rest-list) nargs)
  296.           (instruction (enum op push))
  297.           (instruction (enum op make-env) (+ nargs 1)))
  298.          (instruction (enum op make-env) nargs)))
  299.        (let* ((vars (normalize-formals formals))
  300.           (cenv (bind-vars (reverse vars) cenv)))
  301.      (note-environment
  302.       vars
  303.       (compile-body body
  304.             cenv
  305.             0
  306.             (return-cont name)))))))
  307.  
  308. (define compile-letrec
  309.   (let ((operator/lambda     (get-operator 'lambda syntax-type))
  310.     (operator/set!         (get-operator 'set!   syntax-type))
  311.     (operator/call         (get-operator 'call))
  312.     (operator/unassigned (get-operator 'unassigned)))
  313.     (lambda (node cenv depth cont)
  314.       ;; (if (node-ref node 'pure-letrec) ...)
  315.       (let* ((exp (node-form node))
  316.          (specs (cadr exp))
  317.          (body (cddr exp)))
  318.     (compile-redex (make-node operator/lambda
  319.                   `(lambda ,(map car specs)
  320.                      ,@(map (lambda (spec)
  321.                           (make-node operator/set!
  322.                              `(set! ,@spec)))
  323.                         specs)
  324.                      ,(make-node
  325.                        operator/call
  326.                        `(,(make-node operator/lambda
  327.                              `(lambda () ,@body))))))
  328.                (map (lambda (spec)
  329.                   (make-node operator/unassigned
  330.                      `(unassigned)))
  331.                 specs)
  332.                cenv depth cont)))))
  333.  
  334. (define-compilator 'letrec syntax-type compile-letrec)
  335.  
  336. ; --------------------
  337. ; Deal with internal defines (ugh)
  338.  
  339. (define (compile-body body cenv depth cont)
  340.   (scan-body body
  341.          cenv
  342.          (lambda (defs exps)
  343.            (if (null? defs)
  344.            (compile-begin exps cenv depth cont)
  345.            (compile-letrec
  346.             (make-node operator/letrec
  347.                    `(letrec ,(map (lambda (node)
  348.                             (cdr (node-form node)))
  349.                           defs)
  350.                       ,@exps))
  351.             cenv depth cont)))))
  352.  
  353. (define operator/letrec (get-operator 'letrec))
  354.  
  355. ; --------------------
  356. ; Compile-time continuations
  357. ;
  358. ; A compile-time continuation is a pair (segment . name).  Segment is
  359. ; one of the following:
  360. ;   a return instruction - invoke the current full continuation.
  361. ;   empty-segment - fall through to subsequent instructions.
  362. ;   an ignore-values instruction - ignore values, then fall through.
  363. ; If name is non-#f, then the value delivered to subsequent
  364. ; instructions will be assigned to a variable.  If the value being
  365. ; assigned is a lambda, we can give that lambda that name, for
  366. ; debugging purposes.
  367.  
  368. (define (make-cont seg source-info) (cons seg source-info))
  369. (define cont-segment car)
  370. (define cont-source-info cdr)
  371.  
  372. ; Eventually we may be able to optimize jumps to jumps.  Can't yet.
  373. ;(define (make-jump-cont jump cont)
  374. ;  (if (fall-through-cont? cont)
  375. ;      (make-cont jump (cont-name cont))
  376. ;      cont))
  377.  
  378. (define return-cont-segment (instruction (enum op return)))
  379.  
  380. (define (return-cont name)
  381.   (make-cont return-cont-segment name))
  382.  
  383. (define (return-cont? cont)
  384.   (eq? (cont-segment cont) return-cont-segment))
  385.  
  386. ; Fall through into next instruction
  387.  
  388. (define (fall-through-cont node i)
  389.   (make-cont empty-segment (cons i node)))
  390.  
  391. (define (fall-through-cont? cont)
  392.   (not (return-cont? cont)))
  393.  
  394. ; Ignore return value, then fall through
  395.  
  396. (define ignore-values-segment
  397.   (instruction (enum op ignore-values)))
  398.  
  399. (define (ignore-values-cont node i)
  400.   (make-cont ignore-values-segment (cons i node)))
  401.  
  402. (define (ignore-values-cont? cont)
  403.   (eq? (cont-segment cont) ignore-values-segment))
  404.  
  405. ; Value is in *val*; deliver it to its continuation.
  406. ; No need to generate an ignore-values instruction in this case.
  407.  
  408. (define (deliver-value segment cont)
  409.   (if (ignore-values-cont? cont)    ;+++
  410.       segment
  411.       (sequentially segment (cont-segment cont))))
  412.  
  413. ; For putting names to lambda expressions:
  414.  
  415. (define (named-cont name)
  416.   (make-cont empty-segment name))
  417.  
  418. (define (cont-name cont)
  419.   (if (pair? (cont-source-info cont))
  420.       #f
  421.       (cont-source-info cont)))
  422.  
  423. ; --------------------
  424. ; Compile-time environments
  425.  
  426. (define (bind-vars names cenv)
  427.   (let ((level (+ (environment-level cenv) 1)))
  428.     (lambda (name)
  429.       (if (eq? name funny-name/lexical-level)
  430.       level
  431.       (let loop ((over 1) (names names))
  432.         (cond ((null? names)
  433.            (lookup cenv name))
  434.           ((eq? name (car names))
  435.            (make-binding usual-variable-type (cons level over) #f))
  436.           (else (loop (+ over 1) (cdr names)))))))))
  437.  
  438. (define (initial-cenv cenv)
  439.   (bind1 funny-name/lexical-level -1 cenv))
  440.  
  441. (define (environment-level cenv)
  442.   (lookup cenv funny-name/lexical-level))
  443.  
  444. (define funny-name/lexical-level (string->symbol "Lexical nesting level"))
  445.  
  446. ; Find lookup result that was cached by classifier
  447.  
  448. (define (name-node-binding node cenv)
  449.   (or (node-ref node 'binding)
  450.       (node-form node)))  ; = (lookup cenv (node-form node))
  451.  
  452.  
  453. ; --------------------
  454. ; Utilities
  455.  
  456. ; Produce something for source code that contains a compile-time error.
  457.  
  458. (define (generate-trap cont . stuff)
  459.   (apply warn stuff)
  460.   (sequentially (instruction-with-literal (enum op literal)
  461.                       (cons 'error stuff))
  462.         (deliver-value (instruction (enum op trap))
  463.                    cont)))
  464.  
  465. ; Make a segment smaller, if it seems necessary, by introducing an
  466. ; extra template.  A segment is "too big" if it accesses more literals
  467. ; than the size of the operand in a literal-accessing instruction.
  468. ; The number of literals is unknowable given current representations,
  469. ; so we conservatively shrink the segment when its size exceeds 2
  470. ; times the largest admissible operand value, figuring that it takes
  471. ; at least 2 instruction bytes to use a literal.
  472.  
  473. (define (careful-sequentially seg1 seg2 depth cont)
  474.   (if (and (= depth 0)
  475.        (> (+ (segment-size seg1) (segment-size seg2))
  476.           large-segment-size))
  477.       (if (> (segment-size seg1) (segment-size seg2))
  478.       (sequentially (shrink-segment seg1 (fall-through-cont #f #f))
  479.             seg2)
  480.       (sequentially seg1
  481.             (shrink-segment seg2 cont)))
  482.       (sequentially seg1 seg2)))
  483.  
  484. (define large-segment-size (* byte-limit 2))
  485.  
  486. (define (shrink-segment seg cont)
  487.   (maybe-push-continuation
  488.    (sequentially (instruction-with-template
  489.           (enum op closure)
  490.           (if (return-cont? cont)
  491.               seg
  492.               (sequentially seg
  493.                     (instruction (enum op return))))
  494.           #f)
  495.          (instruction (enum op call) 0))
  496.    0
  497.    cont))
  498.  
  499. ; --------------------
  500. ; Type checking.  This gets called on all nodes.
  501.  
  502. (define (type-check node cenv)
  503.   (if *type-check?*
  504.       (let ((form (node-form node)))
  505.     (if (pair? form)
  506.         (let ((proc-node (car form)))
  507.           (if (node? proc-node)
  508.           (let ((proc-type (node-type proc-node cenv)))
  509.             (cond ((procedure-type? proc-type)
  510.                (if (restrictive? proc-type)
  511.                    (let* ((args (if (eq? *type-check?* 'heavy)
  512.                         (map (lambda (exp)
  513.                                (classify exp cenv)) 
  514.                              (cdr form))
  515.                         (cdr form)))
  516.                       (args-type (make-some-values-type
  517.                           (map (lambda (arg)
  518.                              (meet-type
  519.                               (node-type arg cenv)
  520.                               value-type))
  521.                                args)))
  522.                       (node (make-similar-node node
  523.                                    (cons proc-node
  524.                                      args))))
  525.                  (if (not (meet? args-type
  526.                          (procedure-type-domain proc-type)))
  527.                      (diagnose-call-error node proc-type cenv))
  528.                  node)
  529.                    node))
  530.               ((not (meet? proc-type any-procedure-type))
  531.                ;; Could also check args for one-valuedness.
  532.                (let ((message "non-procedure in operator position"))
  533.                  (warn message
  534.                    (schemify node cenv)
  535.                    `(procedure: ,proc-type))
  536.                  (node-set! node 'type-error message))
  537.                node)
  538.               (else node)))
  539.           node))
  540.         node))
  541.       node))
  542.  
  543. (define (set-type-check?! check?)
  544.   (set! *type-check?* check?))
  545.  
  546. (define *type-check?* 'heavy)
  547.  
  548.  
  549. (define (diagnose-call-error node proc-type cenv)
  550.   (let ((message
  551.      (cond ((not (fixed-arity-procedure-type? proc-type))
  552.         "invalid arguments")
  553.            ((= (procedure-type-arity proc-type)
  554.            (length (cdr (node-form node))))
  555.         "argument type error")
  556.            (else
  557.         "wrong number of arguments"))))
  558.     (warn message
  559.       (schemify node cenv)
  560.       `(procedure wants:
  561.               ,(rail-type->sexp (procedure-type-domain proc-type)
  562.                     #f))
  563.       `(arguments are: ,(map (lambda (arg)
  564.                    (type->sexp (node-type arg cenv) #t))
  565.                  (cdr (node-form node)))))
  566.     (node-set! node 'type-error message)))
  567.  
  568.  
  569. ; Type system loophole
  570.  
  571. (define-compilator 'loophole syntax-type
  572.   (lambda (node cenv depth cont)
  573.     (compile (caddr (node-form node)) cenv depth cont)))
  574.